perm filename SAMB.F4[SAM,LCS] blob sn#437747 filedate 1979-04-27 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	CGEN1      FUNCTION GENERATOR 1 (SEG)   ***  SAM 5  ***     
C00009 ENDMK
CāŠ—;
CGEN1      FUNCTION GENERATOR 1 (SEG)   ***  SAM 5  ***     
      SUBROUTINEGEN1     
      COMMON I(1)/P/ P(1) /GENS/GENS(1)
	1 /LFUNC/LFUNC
	EQUIVALENCE (K,I)

	K=K-1
      N1=1+(IFIX(P(4))-1)*LFUNC     
	GENS(N1)=999
C FLAG FOR SEG FUNC.
	N1=N1+1
	JJ=5
102	GENS(N1)=P(JJ+2)-P(JJ)
C AMPL. CHANGE TO NEXT POINT
	GENS(N1+1)=(P(JJ+3)-1)/99.0
C SINCE FIRST STEP IS 1 AND LAST IS 100.
CC	GENS(N1+1)=(P(JJ+3)-P(JJ+1))/512.
C % OF TIME ON THIS SLOPE
	JJ=JJ+2
	N1=N1+2
	IF(JJ.LT.K)GO TO 102
	GENS(N1)=999
C TERMINATION FLAG=999  
      RETURN      
      END  

CGEN2      FUNCTION GENERATOR 2 (SYNTH)    *** SAM 5 ***     
      SUBROUTINEGEN2     
      COMMON I(1)/P/ P(1) /GENS/GENS(1)
	1 /LFUNC/LFUNC
	EQUIVALENCE (K,I)

      N1=1+(IFIX(P(4))-1)*LFUNC     
	JJ=5
102	GENS(N1)=P(JJ)
C AMPL. OF THIS HARMONIC  
	JJ=JJ+1
	N1=N1+1
	IF(JJ.LT.K)GO TO 102
	GENS(N1)=999
	RETURN
      END  

      SUBROUTINE SAMOUT(IDSK,N)    
	COMMON I(1)  /ROUT/ROUT(1)  /FINOUT/JPEAK,IPEAK,NBUF
	1 /CONV/ICONV,INIOUT,JFLNM 
	COMMON /DEVS/ID1,ID21,JTYPE,ID23,KOUT 
	DATA TEST/'TEST'/
      DIMENSION IDBUF(2048),JDBUF(512),NN(512),LDBUF(512)
 	EQUIVALENCE (IDBUF,JDBUF),(LDBUF,IDBUF(513))
C*** IDBUF WILL STORE PACKED SAMPLES. ****
	IF(ICONV.EQ.0)GO TO 2
	CALL SAMO2(IDSK,N)
C THIS IS FOR INTERACTIVE USE.
	RETURN
2	IF(INIOUT.EQ.0)GO TO 99
C NOW OPEN PROPER OUTPUT FILE
	INIOUT=0
	IDSK=0
	CALL DISKO(ID23,TEST,2)
C   2=UNFORMATTED OUTPUT
C  OUTPUT IS ALWAYS NAMED 'TEST.DAT' FOR NOW.
99    J=IDSK+1
	M1=1
      M2=0
      IDSK=IDSK+N
C  COUNTS SAMPLES TO DATE
      DO 1 K=J,IDSK
      IS=ROUT(M1+M2)
	IA=IABS(IS)
      IF(IA.GT.IPEAK)IPEAK=IA
      IDBUF(K)=IS
1     M2=M2+1
      IF(IDSK.LT.NBUF)RETURN
C NBUF=512,MONO   =1024,STEREO

11	WRITE(ID23)JDBUF
	IF(NBUF.NE.512)WRITE(ID23),LDBUF
C ABOVE FOR STEREO
10    J=IDSK-NBUF
      IF(J.LT.1)GO TO 4
      DO 5 K=1,J
5     IDBUF(K)=IDBUF(NBUF+K)
4     IDSK=J
      RETURN
      END  

CERRO1     GENERAL ERROR ROUTINE    *** MUSIC V ***     
      SUBROUTINE ERROR(I) 
	COMMON /DEVS/ID1,ID21,JTYPE,ID23,KOUT 
      WRITE(JTYPE,100),I  
  100 FORMAT (' ERROR OF TYPE',I5/)     
      RETURN      
      END